perm filename REDCOM.LSP[CMP,LSP] blob
sn#331929 filedate 1978-01-28 generic text, type T, neo UTF8
(DE EQCAR (U V) (AND (NOT (ATOM U)) (EQ (CAR U) V)))
(DE LPRIE (U)
(PROGN (PRINT (CONS (QUOTE ******) U)) (ERROR 121 NIL)))
(DE MKQUOTE (U) (LIST (QUOTE QUOTE) U))
(DE REVERSIP (U)
(PROG (X Y)
(PROG NIL
G0011(COND ((NOT U) (RETURN NIL)))
(PROGN (SETQ X (CDR U))
(SETQ Y (RPLACD U Y))
(SETQ U X))
(GO G0011))
(RETURN Y)))
(DE RPLACW (A B) (RPLACA (RPLACD A (CDR B)) (CAR B)))
(DE NCONS (U) (CONS U NIL))
(DE XCONS (U V) (CONS V U))
(GLOBAL (QUOTE (*MODULE *NOLINKL *NOLINKR *ORD *PLAP *R2I *SAVEDEF)))
(GLOBAL (QUOTE (MAXNARGS)))
(FLUID (QUOTE (ALSTS FLAGG
NAME
GOLIST
IREGS
CODELIST
CONDTAIL
LLNGTH
NARG
REGS
RETN
LBLIST
JMPLIST
SLST
STLST
STOMAP
SWITCH
REGS1
IREGS1
FREELST)))
(DE COMPILE (X)
(PROG (EXP NAME)
(PROG NIL
G0012(COND ((NOT X) (RETURN NIL)))
(PROGN (SETQ NAME (CAR X))
(SETQ EXP (GETD NAME))
(COND ((NULL EXP)
(LPRIM (LIST NAME (QUOTE UNDEFINED))))
(T (COMPD NAME (CAR EXP) (CDR EXP))))
(SETQ X (CDR X)))
(GO G0012))))
(DE COMPD (NAME TYPE EXP)
(PROG (CTYPE)
(COND ((EQ TYPE (QUOTE EXPR)) (SETQ CTYPE (QUOTE SUBR)))
((EQ TYPE (QUOTE FEXPR)) (SETQ CTYPE (QUOTE FSUBR)))
(T (PROGN (LPRIM (LIST (QUOTE UNCOMPILABLE
FUNCTION
TYPE)
TYPE))
(RETURN NIL))))
(COND
((NOT (ATOM EXP))
(COND (*MODULE (MODCMP NAME TYPE EXP))
(DFPRINT* (APPLY DFPRINT*
(LIST (LIST (COND ((EQ TYPE
(QUOTE EXPR))
(QUOTE DE))
(T (QUOTE DF)))
NAME
(CADR EXP)
(CADDR EXP)))))
(T (PROG (X)
(SETQ X (CONS (LIST (QUOTE *ENTRY)
NAME
CTYPE
(LENGTH (CADR EXP)))
(&COMPROC EXP NAME)))
(COND (*PLAP (MAPC (FUNCTION (LAMBDA (Y)
(PRINT Y)))
X)))
(COND (*SAVEDEF (PUT NAME
(QUOTE COMPEXP)
(CONS TYPE X)))
(T (PROGN (REMD NAME) (LAP X)))))))))
(RETURN NAME)))
(DE &COMPROC (EXP NAME)
(PROG (CODELIST FLAGG IREGS IREGS1 JMPLIST LBLIST LLNGTH REGS REGS1
ALSTS RETN SLST STLST STOMAP CONDTAIL REGS1 IREGS1 FREELST
NARG)
(SETQ LLNGTH (LIST 0))
(SETQ NARG 0)
(SETQ RETN (&GENLBL))
(SETQ STOMAP (QUOTE ((NIL 0))))
(SETQ CODELIST (LIST (CONS (QUOTE *ALLOC) LLNGTH)))
(SETQ EXP (&PA1 EXP NIL))
(MAPC (FUNCTION (LAMBDA (Z)
(PROGN (&FRAME Z)
(SETQ NARG (PLUS NARG 1))
(COND ((NOT (NONLOCAL Z))
(SETQ IREGS
(NCONC IREGS
(LIST (LIST NARG
Z))))))
(SETQ REGS (NCONC REGS
(LIST (LIST NARG
Z)))))))
(CADR EXP))
(COND ((NULL REGS) (SETQ REGS (LIST (CONS 1 NIL)))))
(SETQ ALSTS (&FREEBIND (CADR EXP) T))
(&COMVAL (CADDR EXP) 0)
(&FREERSTR ALSTS 0)
(RETURN (&FIXUPS))))
(DE NONLOCAL (X)
(COND ((FLUIDP X) (QUOTE FLUID))
((GLOBALP X) (QUOTE GLOBAL))
(T NIL)))
(FLUID (QUOTE (VARS)))
(DE &PA1 (U VARS)
(PROG (X)
(RETURN (COND ((ATOM U) (COND ((OR (CONSTANTP U)
(MEMQ U (QUOTE (NIL T))))
(MKQUOTE U))
((MEMBER U VARS) U)
((OR (GLOBALP U) (FLUIDP U)) U)
(T (PROGN (MKNONLOCAL U) U))))
((NOT (ATOM (CAR U)))
(CONS (&PA1 (CAR U) VARS)
(&PALIS (CDR U) VARS)))
((AND (SETQ X (GET (CAR U) (QUOTE MACRO)))
(NOT (GET (CAR U) (QUOTE COMPFN))))
(&PA1 (APPLY X (LIST U)) VARS))
((EQ (CAR U) (QUOTE NOT))
(&PA1 (CONS (QUOTE NULL) (CDR U)) VARS))
((EQ (CAR U) (QUOTE COND))
(CONS (QUOTE COND)
(MAPCAR (FUNCTION (LAMBDA (Z)
(LIST (&PA1 (CAR Z)
VARS)
(&PA1 (CADR Z)
VARS))))
(CDR U))))
((MEMBER (CAR U) (QUOTE (GO QUOTE))) U)
((EQ (CAR U) (QUOTE LAMBDA))
(CONS (QUOTE LAMBDA)
(CONS (CADR U)
(&PALIS (CDDR U)
(APPEND (CADR U) VARS)))))
((EQ (CAR U) (QUOTE FUNCTION))
(COND ((ATOM (CADR U)) (MKQUOTE (CADR U)))
(T (MKQUOTE (COMPD (&MKNAM NAME)
(QUOTE EXPR)
(CADR U))))))
((SETQ X (GET (CAR U) (QUOTE PA1FN)))
(APPLY X (LIST U VARS)))
((EQ (CAR U) (QUOTE PROG))
(CONS (QUOTE PROG)
(CONS (CADR U)
(&PAPROG (CDDR U)
(APPEND (CADR U) VARS)))))
((AND (SETQ X (GETD (CAR U)))
(MEMQ (CAR X) (QUOTE (FEXPR FSUBR)))
(NOT (GET (CAR U) (QUOTE COMPFN))))
(PROGN (&PALIS (CDR U) NIL)
(LIST (CAR U) (MKQUOTE (CDR U)))))
(T (CONS (CAR U) (&PALIS (CDR U) VARS)))))))
(DE &PALIS (U VARS) (MAPCAR (FUNCTION (LAMBDA (X) (&PA1 X VARS))) U))
(DE &PAPROG (U VARS)
(MAPCAR (FUNCTION (LAMBDA (X)
(COND ((ATOM X) X) (T (&PA1 X VARS)))))
U))
(DE MKNONLOCAL (U)
(PROGN (LPRIM (LIST U (QUOTE DECLARED FLUID)))
(FLUID (LIST U))
(LIST (QUOTE FLUID) U)))
(DE &MKNAM (U) (COMPRESS (APPEND (EXPLODE U) (EXPLODE (GENSYM)))))
(UNFLUID (QUOTE (VARS)))
(DE &COMVAL (EXP STATUS)
(COND ((&ANYREG EXP NIL)
(COND ((GREATERP STATUS 1) NIL) (T (&LREG1 EXP STATUS))))
(T (&COMVAL1 EXP STOMAP STATUS))))
(DE &COMVAL1 (EXP STOMAP STATUS)
(PROG (X)
(COND ((ATOM EXP)
(COND ((LESSP STATUS 2) (&LREG1 EXP STATUS)) (T NIL)))
((NOT (ATOM (CAR EXP)))
(COND ((EQ (CAAR EXP) (QUOTE LAMBDA))
(&COMPLY (CAR EXP) (CDR EXP) STATUS))
(T (&COMAPPLY (LIST (QUOTE APPLY)
(CAR EXP)
(&PALIST (CDR EXP)))
STATUS))))
((SETQ X (GET (CAR EXP) (QUOTE COMPFN)))
(APPLY X (LIST EXP STATUS)))
((ATSOC (CAR EXP) STOMAP)
(&COMAPPLY (LIST (QUOTE APPLY)
(CAR EXP)
(&PALIST (CDR EXP)))
STATUS))
((AND *R2I
(EQ (CAR EXP) NAME)
(EQ STATUS 0)
(NULL FREELST))
(&COMREC EXP STATUS))
(T (&CALL (CAR EXP) (&COMLIS (CDR EXP)) STATUS)))
(RETURN NIL)))
(DE &ANYREG (U V)
(OR (AND (NOT (ATOM U)) (EQ (CAR U) (QUOTE QUOTE)))
(AND (COND ((ATOM U)
(OR (AND (NOT (NONLOCAL U)) (ATSOC U STOMAP))
(&ANYREGL V)))
(T (AND (GET (CAR U) (QUOTE ANYREG))
(&ANYREG (CADR U) NIL))))
(OR (NULL *ORD) (&ANYREGL V)))))
(DE &ANYREGL (U)
(OR (NULL U) (AND (&ANYREG (CAR U) NIL) (&ANYREGL (CDR U)))))
(DE &CALL (FN ARGS STATUS)
(PROG (ARGNO)
(SETQ ARGNO (LENGTH ARGS))
(&LOADARGS ARGS STATUS)
(COND ((AND (NOT *NOLINKL)
(EQ (CAAR CODELIST) (QUOTE *LOAD))
(EQ (CADAR CODELIST) 1)
(NUMBERP (CADDAR CODELIST))
(LEQ (CADDAR CODELIST) MAXNARGS))
(PROGN (&ATTACH (CONS (QUOTE *LINKL)
(CONS FN
(CONS ARGNO
(CDDAR CODELIST)))))
(&MOVEUP (CDR CODELIST))))
(T (&ATTACH (LIST (QUOTE *LINK) FN ARGNO))))
(SETQ REGS (LIST (CONS 1 NIL)))))
(DE &COMLIS (EXP)
(PROG (ACUSED Y)
(PROG NIL
G0013(COND ((NOT EXP) (RETURN NIL)))
(PROGN (COND ((&ANYREG (CAR EXP) (CDR EXP))
(SETQ Y (CONS (CAR EXP) Y)))
(T (PROGN (COND (ACUSED (&STORE1)))
(&COMVAL1 (CAR EXP) STOMAP 1)
(SETQ ACUSED (GENSYM))
(SETQ REGS
(CONS (CONS 1
(CONS ACUSED
(CDAR REGS)))
(CDR REGS)))
(SETQ Y (CONS ACUSED Y)))))
(SETQ EXP (CDR EXP)))
(GO G0013))
(RETURN Y)))
(DE &STORE1 NIL
(PROG (X)
(SETQ X (CADAR REGS))
(COND ((OR (NULL X) (EQCAR X (QUOTE QUOTE))) (RETURN NIL))
((NOT (ATSOC X STOMAP)) (&FRAME X)))
(&STORE X 1)))
(DE &COMPLY (FN ARGS STATUS)
(PROG (ALSTS VARS N I)
(SETQ VARS (CADR FN))
(SETQ ARGS (&COMLIS ARGS))
(SETQ N (LENGTH ARGS))
(COND ((GREATERP N MAXNARGS)
(LPRIE (LIST (QUOTE TOO MANY LAMBDA ARGS IN) NAME))))
(&LOADARGS ARGS 1)
(SETQ ARGS (&REMVARL VARS))
(SETQ I 1)
(MAPC
(FUNCTION (LAMBDA (V)
(PROGN (&FRAME V)
(SETQ REGS (&REPASC I V REGS))
(SETQ I (PLUS I 1)))))VARS)
(SETQ ALSTS (&FREEBIND VARS T))
(SETQ I 1)
(MAPC
(FUNCTION (LAMBDA (V)
(PROGN (COND ((NOT (NONLOCAL V)) (&STORE V I)))
(SETQ I (PLUS I 1)))))VARS)
(&COMVAL (CADDR FN) STATUS)
(&FREERSTR ALSTS STATUS)
(&RSTVARL VARS ARGS)))
(DE &COMREC (EXP STATUS)
(PROG (X Z)
(&LOADARGS (&COMLIS (CDR EXP)) STATUS)
(SETQ Z CODELIST)
(PROG NIL
G0014(COND ((NOT (CDDR Z)) (RETURN NIL)))
(SETQ Z (CDR Z))
(GO G0014))
(COND ((EQ (CAAR Z) (QUOTE *LBL)) (SETQ X (CDAR Z)))
(T (PROGN (SETQ X (&GENLBL))
(RPLACD Z
(LIST (CONS (QUOTE *LBL) X) (CADR Z))))))
(&ATTJMP X)))
(DE &LOADARGS (ARGS STATUS)
(PROG (N)
(SETQ N (LENGTH ARGS))
(COND ((GREATERP N MAXNARGS)
(LPRIE (LIST (QUOTE TOO MANY ARGUMENTS IN) NAME))))
(COND ((GREATERP STATUS 0) (&CLRREGS)))
(PROG NIL
G0015(COND ((NOT ARGS) (RETURN NIL)))
(PROGN (&LREG N (CAR ARGS) (CDR ARGS) STATUS)
(SETQ N (DIFFERENCE N 1))
(SETQ ARGS (CDR ARGS)))
(GO G0015))))
(DE &LOCATE (X)
(PROG (Y VTYPE)
(COND ((EQCAR X (QUOTE QUOTE)) (RETURN (LIST X)))
((SETQ Y (&RASSOC X REGS))
(RETURN (LIST (LIST (QUOTE *REG) (CAR Y)))))
((NOT (ATOM X))
(RETURN (LIST (CONS (CAR X) (&LOCATE (CADR X))))))
((SETQ VTYPE (NONLOCAL X))
(RETURN (LIST (LIST VTYPE X)))))
(PROG NIL
G0016(COND ((NOT (SETQ Y (ATSOC X SLST))) (RETURN NIL)))
(SETQ SLST (DELETE Y SLST))
(GO G0016))
(RETURN (COND ((SETQ Y (ATSOC X STOMAP)) (CDR Y))
(T (LIST (MKNONLOCAL X)))))))
(DE &LREG (REG U V STATUS)
(PROG (X Y)
(COND ((AND (SETQ X (ASSOC REG REGS)) (MEMBER U (CDR X)))
(RETURN NIL))
((AND (SETQ Y (ASSOC REG IREGS))
(OR (GREATERP STATUS 0) (&MEMLIS (CADR Y) V)))
(PROGN (&STORE (CADR Y) REG)
(SETQ IREGS (DELETE Y IREGS)))))
(&ATTACH (CONS (QUOTE *LOAD) (CONS REG (&LOCATE U))))
(SETQ REGS (&REPASC REG U REGS))))
(DE &LREG1 (X STATUS) (&LREG 1 X NIL STATUS))
(DE &PALIST (U) (CONS (QUOTE LIST) U))
(DE &FREEBIND (VARS LAMBP)
(PROG (FALST FREGS X Y I)
(SETQ I 1)
(MAPC
(FUNCTION (LAMBDA (X)
(PROGN (COND ((FLUIDP X)
(PROGN (SETQ FALST
(CONS (CONS X (&GETFFRM X))
FALST))
(SETQ FREGS (CONS I FREGS))))
((GLOBALP X)
(LPRIE (LIST (QUOTE CANNOT
BIND
GLOBAL)
X))))
(SETQ I (PLUS I 1)))))
VARS)
(COND ((NULL FALST) (RETURN NIL)))
(COND (LAMBP (&ATTACH (LIST (QUOTE *LAMBIND) FREGS FALST)))
(T (&ATTACH (LIST (QUOTE *PROGBIND) FALST))))
(RETURN FALST)))
(DE &FREERSTR (ALSTS STATUS)
(COND (ALSTS (&ATTACH (LIST (QUOTE *FREERSTR) ALSTS))) (T NIL)))
(DE &ATTACH (U) (SETQ CODELIST (CONS U CODELIST)))
(DE &STORE (U REG)
(PROG (X)
(SETQ X (CONS (QUOTE *STORE) (CONS REG (&GETFRM U))))
(SETQ STLST (CONS X STLST))
(&ATTACH X)
(COND ((AND (NULL CONDTAIL) (SETQ X (ATSOC U SLST)))
(PROGN (SETQ STLST (&DELEQ (CADR X) STLST))
(SETQ SLST (&DELEQ X SLST))
(RPLACA (CADR X) (QUOTE *NOOP)))))
(COND ((ATOM U) (SETQ SLST (CONS (CONS U CODELIST) SLST))))))
(DE &COMTST (EXP LABL)
(PROG (X)
(PROG NIL
G0017(COND ((NOT (EQCAR EXP (QUOTE NULL))) (RETURN NIL)))
(PROGN (SETQ SWITCH (NOT SWITCH)) (SETQ EXP (CADR EXP)))
(GO G0017))
(COND
((AND (NOT (ATOM EXP))
(ATOM (CAR EXP))
(SETQ X (GET (CAR EXP) (QUOTE COMTST))))
(APPLY X (LIST EXP LABL)))
(T (PROGN
(COND
((EQUAL EXP (QUOTE (QUOTE T)))
(COND (SWITCH (&ATTJMP LABL)) (T (SETQ FLAGG T))))
(T (PROGN (&COMVAL EXP 1)
(&ATTACH (LIST (COND (SWITCH (QUOTE *JUMPT))
(T (QUOTE *JUMPNIL)))
(CAR LABL)))
(&ADDJMP CODELIST))))
(SETQ REGS1 REGS)
(SETQ IREGS1 IREGS))))
(COND ((EQCAR (CAR CODELIST) (QUOTE *JUMPT))
(SETQ REGS (CONS (CONS 1
(CONS (QUOTE (QUOTE NIL))
(CDAR REGS)))
(CDR REGS))))
((EQCAR (CAR CODELIST) (QUOTE *JUMPNIL))
(SETQ REGS1 (CONS (CONS 1
(CONS (QUOTE (QUOTE NIL))
(CDAR REGS1)))
(CDR REGS1)))))))
(DE &COMANDOR (EXP STATUS)
(PROG (FN LABL IREGSL REGSL)
(SETQ FN (EQ (CAR EXP) (QUOTE AND)))
(SETQ LABL (&GENLBL))
(COND
((GREATERP STATUS 1)
(PROGN (&TSTANDOR EXP LABL)
(SETQ REGS (&RMERGE2 REGS REGS1))))
(T (PROG NIL
(COND ((GREATERP STATUS 0) (&CLRREGS)))
(SETQ EXP (CDR EXP))
(PROG NIL
G0018(COND ((NOT EXP) (RETURN NIL)))
(PROGN
(&COMVAL (CAR EXP)
(COND ((CDR EXP) 1) (T STATUS)))
(SETQ IREGSL (CONS IREGS IREGSL))
(SETQ REGSL (CONS REGS REGSL))
(COND
((CDR EXP)
(PROGN
(&ATTACH (LIST (COND (FN (QUOTE *JUMPNIL))
(T (QUOTE *JUMPT)))
(CAR LABL)))
(&ADDJMP CODELIST))))
(SETQ EXP (CDR EXP)))
(GO G0018))
(SETQ IREGS (&RMERGE IREGSL))
(SETQ REGS (&RMERGE REGSL)))))
(&ATTLBL LABL)))
(DE &TSTANDOR (EXP LABL)
(PROG (FLG FN LAB2 REGSL REGS1L TAILP)
(SETQ FLG SWITCH)
(SETQ SWITCH NIL)
(SETQ FN (EQ (CAR EXP) (QUOTE AND)))
(SETQ EXP (CDR EXP))
(SETQ LAB2 (&GENLBL))
(&CLRREGS)
(PROG NIL
G0019(COND ((NOT EXP) (RETURN NIL)))
(PROGN
(SETQ SWITCH NIL)
(COND ((AND (NULL (CDR EXP)) (EQ FLG FN))
(PROGN (COND (FN (SETQ SWITCH T)))
(&COMTST (CAR EXP) LABL)
(SETQ REGSL (CONS REGS REGSL))
(SETQ REGS1L (CONS REGS1 REGS1L))))
(T (PROGN (COND ((NOT FN) (SETQ SWITCH T)))
(COND ((EQ FLG FN)
(PROGN (&COMTST (CAR EXP) LAB2)
(SETQ REGSL (CONS REGS1
REGSL))
(SETQ REGS1L
(CONS REGS
REGS1L))))
(T (PROGN (&COMTST (CAR EXP)
LABL)
(SETQ REGSL
(CONS REGS
REGSL))
(SETQ REGS1L
(CONS REGS1
REGS1L))))))))
(COND ((NULL TAILP)
(PROGN (SETQ CONDTAIL (CONS NIL CONDTAIL))
(SETQ TAILP T))))
(SETQ EXP (CDR EXP)))
(GO G0019))
(&ATTLBL LAB2)
(SETQ REGS (COND (FN (CAR REGSL)) (T (&RMERGE REGSL))))
(SETQ REGS1 (COND ((NULL FN) (CAR REGS1L))
(T (&RMERGE REGS1L))))
(COND (TAILP (SETQ CONDTAIL (CDR CONDTAIL))))
(SETQ SWITCH FLG)))
(PUT (QUOTE AND) (QUOTE COMPFN) (QUOTE &COMANDOR))
(PUT (QUOTE OR) (QUOTE COMPFN) (QUOTE &COMANDOR))
(DE &COMCOND (EXP STATUS)
(PROG (GOCHN IREGS1 REGS1 FLAGG SWITCH LAB1 LAB2 REGSL IREGSL TAILP)
(SETQ EXP (CDR EXP))
(SETQ LAB1 (&GENLBL))
(SETQ GOCHN T)
(COND ((GREATERP STATUS 0) (&CLRREGS)))
(MAPC (FUNCTION (LAMBDA (X)
(PROGN (SETQ LAB2 (&GENLBL))
(SETQ SWITCH NIL)
(&COMTST (CAR X) LAB2)
(COND ((NULL TAILP)
(PROGN (SETQ CONDTAIL
(CONS NIL
CONDTAIL))
(SETQ TAILP T))))
(&COMVAL (CADR X) STATUS)
(COND ((NOT (EQCAR (CAR CODELIST)
(QUOTE *JUMP)))
(PROGN (SETQ GOCHN NIL)
(&ATTJMP LAB1))))
(SETQ IREGSL (CONS IREGS IREGSL))
(SETQ REGSL (CONS REGS REGSL))
(SETQ REGS REGS1)
(SETQ IREGS IREGS1)
(&ATTLBL LAB2))))
EXP)
(COND ((AND (NULL FLAGG) (LESSP STATUS 2))
(PROGN (&LREG1 (QUOTE (QUOTE NIL)) STATUS)
(SETQ IREGSL (CONS IREGS IREGSL))
(SETQ REGSL (CONS REGS REGSL)))))
(COND ((NULL GOCHN)
(PROGN (SETQ IREGS (&RMERGE (CONS IREGS IREGSL)))
(SETQ REGS (&RMERGE (CONS REGS REGSL))))))
(&ATTLBL LAB1)
(COND (TAILP (SETQ CONDTAIL (CDR CONDTAIL))))))
(DE &RMERGE (U) (COND ((NULL U) NIL) (T (&RMERGE1 (CAR U) (CDR U)))))
(DE &RMERGE1 (U V)
(COND ((NULL V) U) (T (&RMERGE1 (&RMERGE2 U (CAR V)) (CDR V)))))
(DE &RMERGE2 (U V)
(COND ((OR (NULL U) (NULL V)) NIL)
(T ((LAMBDA (X)
(COND (X (CONS (CONS (CAAR U) (XN (CDAR U) (CDR X)))
(&RMERGE2 (CDR U) (DELETE X V))))
(T (&RMERGE2 (CDR U) V))))
(ASSOC (CAAR U) V)))))
(PUT (QUOTE COND) (QUOTE COMPFN) (QUOTE &COMCOND))
(DE &COMCONS (EXP STATUS)
(COND ((OR (NULL (SETQ EXP (CDR EXP))) (NULL (CDR EXP)) (CDDR EXP))
(LPRIE (QUOTE MISMATCH OF ARGUMENTS)))
((EQUAL (CADR EXP) (QUOTE (QUOTE NIL)))
(&CALL (QUOTE NCONS) (&COMLIS (LIST (CAR EXP))) STATUS))
((&ANYREG (CADR EXP) NIL)
(&CALL (QUOTE CONS) (&COMLIS EXP) STATUS))
(T (&CALL (QUOTE XCONS) (REVERSIP (&COMLIS EXP)) STATUS))))
(PUT (QUOTE CONS) (QUOTE COMPFN) (QUOTE &COMCONS))
(DE &COMGO (EXP STATUS)
(COND ((GREATERP STATUS 2)
(PROGN (&ATTJMP (&GETLBL (CADR EXP))) (SETQ SLST NIL)))
(T (LPRIE (QUOTE INVALID GO STATEMENT)))))
(PUT (QUOTE GO) (QUOTE COMPFN) (QUOTE &COMGO))
(DE &COMLIST (EXP STATUS)
(PROG (M N FN)
(SETQ EXP (CDR EXP))
(SETQ M (MIN MAXNARGS 5))
(SETQ N (LENGTH EXP))
(COND ((EQ N 0) (&LREG1 (QUOTE (QUOTE NIL)) STATUS))
((GREATERP N M) (&COMVAL (&COMLIST2 EXP) STATUS))
(T (&CALL (COND ((EQ N 1) (QUOTE NCONS))
((EQ N 2) (QUOTE LIST2))
((EQ N 3) (QUOTE LIST3))
((EQ N 4) (QUOTE LIST4))
(T (QUOTE LIST5)))
(&COMLIS EXP)
STATUS)))))
(DE LIST2 (U V) (CONS U (CONS V NIL)))
(DE LIST3 (U V W) (CONS U (CONS V (CONS W NIL))))
(DE LIST4 (U V W X) (CONS U (CONS V (CONS W (CONS X NIL)))))
(DE LIST5 (U V W X Y)
(CONS U (CONS V (CONS W (CONS X (CONS Y NIL))))))
(DE &COMLIST2 (EXP)
(PROG (L1 N)
(SETQ N (MIN MAXNARGS 5))
(PROG NIL
G0020(COND ((NOT (GREATERP N 0)) (RETURN NIL)))
(PROGN (SETQ L1 (CONS (CAR EXP) L1))
(SETQ EXP (CDR EXP))
(SETQ N (DIFFERENCE N 1)))
(GO G0020))
(RETURN (LIST (QUOTE NCONC)
(CONS (QUOTE LIST) (REVERSIP L1))
(CONS (QUOTE LIST) EXP)))))
(PUT (QUOTE LIST) (QUOTE COMPFN) (QUOTE &COMLIST))
(DE &PAMAP (U VARS)
(COND ((EQCAR (CADDR U) (QUOTE FUNCTION))
((LAMBDA (X)
(LIST (CAR U)
(&PA1 (CADR U) VARS)
(MKQUOTE (COND ((ATOM X) X) (T (&PA1 X VARS))))))
(CADR (CADDR U))))
(T (CONS (CAR U) (&PALIS (CDR U) VARS)))))
(PUT (QUOTE MAP) (QUOTE PA1FN) (QUOTE &PAMAP))
(PUT (QUOTE MAPC) (QUOTE PA1FN) (QUOTE &PAMAP))
(DE &MAP (EXP STATUS)
(PROG (BODY FN LAB1 LAB2 SLST1 VAR X)
(SETQ BODY (CADR EXP))
(SETQ FN (CADDR EXP))
(SETQ LAB1 (&GENLBL))
(SETQ LAB2 (&GENLBL))
(&CLRREGS)
(&FRAME (SETQ VAR (GENSYM)))
(&COMVAL BODY 1)
(SETQ REGS (LIST (LIST 1 VAR)))
(&ATTLBL LAB1)
(&ATTACH (LIST (QUOTE *JUMPNIL) (CAR LAB2)))
(&ADDJMP CODELIST)
(&STORE VAR 1)
(SETQ X (COND ((EQ (CAR EXP) (QUOTE MAP)) VAR)
(T (LIST (QUOTE CAR) VAR))))
(COND ((EQCAR FN (QUOTE QUOTE)) (SETQ FN (CADR FN))))
(SETQ SLST1 SLST)
(&COMVAL (LIST FN X) 3)
(SETQ SLST (XN SLST SLST1))
(&COMVAL (LIST (QUOTE CDR) VAR) 1)
(&ATTJMP LAB1)
(&ATTLBL LAB2)
(SETQ REGS (LIST (LIST 1 (MKQUOTE NIL))))))
(DE XN (U V)
(COND ((NULL U) NIL)
((MEMBER (CAR U) V)
(CONS (CAR U) (XN (CDR U) (DELETE (CAR U) V))))
(T (XN (CDR U) V))))
(PUT (QUOTE MAP) (QUOTE COMPFN) (QUOTE &MAP))
(PUT (QUOTE MAPC) (QUOTE COMPFN) (QUOTE &MAP))
(DE &COMPROG (EXP STATUS)
(PROG (ALSTS GOLIST PG PROGLIS RETN I)
(SETQ PROGLIS (CADR EXP))
(SETQ EXP (CDDR EXP))
(SETQ RETN (&GENLBL))
(SETQ PG (&REMVARL PROGLIS))
(MAPC PROGLIS (FUNCTION (LAMBDA (X) (&FRAME X))))
(SETQ ALSTS (&FREEBIND PROGLIS NIL))
(MAPC (FUNCTION (LAMBDA (X)
(COND ((NOT (NONLOCAL X)) (&STORE X NIL)))))
PROGLIS)
(MAPC (FUNCTION (LAMBDA (X)
(COND ((ATOM X)
(SETQ GOLIST (CONS (CONS X (&GENLBL))
GOLIST))))))
EXP)
(PROG NIL
G0021(COND ((NOT EXP) (RETURN NIL)))
(PROGN
(COND ((ATOM (CAR EXP))
(PROGN (&CLRREGS)
(&ATTLBL (&GETLBL (CAR EXP)))
(SETQ REGS (LIST (CONS 1 NIL)))))
(T (&COMVAL (CAR EXP)
(COND ((GREATERP STATUS 2) 4)
(T 3)))))
(COND ((AND (NULL (CDR EXP))
(LESSP STATUS 2)
(OR (ATOM (CAR EXP))
(NOT (MEMBER (CAAR EXP)
(QUOTE (GO RETURN))))))
(SETQ EXP (LIST (QUOTE (RETURN (QUOTE NIL))))))
(T (SETQ EXP (CDR EXP)))))
(GO G0021))
(&ATTLBL RETN)
(COND ((CDR (&FINDLBL RETN)) (SETQ REGS (LIST (CONS 1 NIL)))))
(&FREERSTR ALSTS STATUS)
(&RSTVARL PROGLIS PG)))
(PUT (QUOTE PROG) (QUOTE COMPFN) (QUOTE &COMPROG))
(DE &REMVARL (VARS)
(MAPCAR (FUNCTION (LAMBDA (X) (&REMVAR X))) VARS))
(DE &REMVAR (X)
(PROG NIL
(MAPC (FUNCTION (LAMBDA (Y)
(COND ((EQ X (CADR Y))
(PROGN (&STORE (CADR Y) (CAR Y))
(SETQ IREGS
(DELETE Y IREGS)))))))
IREGS)
(MAPC (FUNCTION (LAMBDA (Y)
(PROG NIL
G0022(COND ((NOT (MEMBER X (CDR Y)))
(RETURN NIL)))
(RPLACD Y (&DELEQ X (CDR Y)))
(GO G0022))))
REGS)
(RETURN (&PROTECT X))))
(DE &PROTECT (U)
(PROG (X)
(COND ((SETQ X (ATSOC U SLST)) (SETQ SLST (&DELEQ X SLST))))
(RETURN X)))
(DE &RSTVARL (VARS LST)
(PROG NIL
G0023(COND ((NOT VARS) (RETURN NIL)))
(PROGN (&RSTVAR (CAR VARS) (CAR LST))
(SETQ VARS (CDR VARS))
(SETQ LST (CDR LST)))
(GO G0023)))
(DE &RSTVAR (VAR VAL)
(PROG NIL
(MAPC (FUNCTION (LAMBDA (X)
(COND ((EQ VAR (CADR X))
(PROGN (&STORE (CADR X) (CAR X))
(SETQ IREGS
(DELETE X IREGS)))))))
IREGS)
(MAPC (FUNCTION (LAMBDA (X)
(PROG NIL
G0024(COND ((NOT (MEMBER VAR (CDR X)))
(RETURN NIL)))
(RPLACD X (&DELEQ VAR (CDR X)))
(GO G0024))))
REGS)
(&CLRSTR VAR)
(&UNPROTECT VAL)))
(DE &CLRSTR (VAR)
(PROG (X)
(COND (CONDTAIL (RETURN NIL)))
(SETQ X (ATSOC VAR SLST))
(COND ((NULL X) (RETURN NIL)))
(SETQ STLST (&DELEQ (CADR X) STLST))
(SETQ SLST (&DELEQ X SLST))
(RPLACA (CADR X) (QUOTE *NOOP))))
(DE &UNPROTECT (VAL)
(COND (VAL (SETQ SLST (CONS VAL SLST))) (T NIL)))
(DE &COMPROGN (EXP STATUS)
(PROG NIL
(SETQ EXP (CDR EXP))
(PROG NIL
G0025(COND ((NOT (CDR EXP)) (RETURN NIL)))
(PROGN (&COMVAL (CAR EXP)
(COND ((LESSP STATUS 2) 2) (T STATUS)))
(SETQ EXP (CDR EXP)))
(GO G0025))
(&COMVAL (CAR EXP) STATUS)))
(PUT (QUOTE PROG2) (QUOTE COMPFN) (QUOTE &COMPROGN))
(PUT (QUOTE PROGN) (QUOTE COMPFN) (QUOTE &COMPROGN))
(DE &COMRETURN (EXP STATUS)
(PROGN (COND ((OR (LESSP STATUS 4) (NOT (&ANYREG (CADR EXP) NIL)))
(&LREG1 (CAR (&COMLIS (LIST (CADR EXP)))) STATUS))
(T NIL))
(&ATTJMP RETN)))
(PUT (QUOTE RETURN) (QUOTE COMPFN) (QUOTE &COMRETURN))
(DE &COMSETQ (EXP STATUS)
(PROG (X)
(SETQ EXP (CDR EXP))
(COND ((AND (GREATERP STATUS 1)
(OR (NULL (CADR EXP))
(EQUAL (CADR EXP) (QUOTE (QUOTE NIL)))))
(&STORE2 (CAR EXP) NIL))
(T (PROGN (&COMVAL (CADR EXP) 1)
(SETQ REGS (&REMSETVAR REGS (CAR EXP)))
(&STORE2 (CAR EXP) 1)
(COND ((SETQ X (&RASSOC (CAR EXP) IREGS))
(SETQ IREGS (DELETE X IREGS))))
(SETQ REGS (CONS (CONS 1
(CONS (CAR EXP)
(CDAR REGS)))
(CDR REGS))))))))
(DE &REMSETVAR (U V)
(COND ((NULL U) NIL)
(T (CONS (CONS (CAAR U) (&REMS1 (CDAR U) V))
(&REMSETVAR (CDR U) V)))))
(DE &REMS1 (U V)
(COND ((NULL U) NIL)
((ATOM U) (COND ((EQ U V) (&REMS1 (CDR U) V))
(T (CONS (CAR U) (&REMS1 (CDR U) V)))))
((OR (EQ (CAR U) (QUOTE QUOTE))
(NOT (MEMBER V (FLATTEN (CAR U)))))
(CONS (CAR U) (&REMS1 (CDR U) V)))
(T (&REMS1 (CDR U) V))))
(DE &STORE2 (U V)
(PROG (VTYPE)
(COND ((SETQ VTYPE (NONLOCAL U))
(&ATTACH (LIST (QUOTE *STORE) V (LIST VTYPE U))))
((NOT (ATSOC U STOMAP))
(&ATTACH (LIST (QUOTE *STORE) V (MKNONLOCAL U))))
(T (&STORE U V)))))
(PUT (QUOTE SETQ) (QUOTE COMPFN) (QUOTE &COMSETQ))
(PUT (QUOTE AND) (QUOTE COMTST) (QUOTE &TSTANDOR))
(PUT (QUOTE OR) (QUOTE COMTST) (QUOTE &TSTANDOR))
(DE &CEQ (EXP LABL)
(PROG (U V W)
(SETQ U (CADR EXP))
(SETQ V (CADDR EXP))
(COND ((MEMBER U (CDAR REGS)) (SETQ W (&CEQ1 V U)))
((MEMBER V (CDAR REGS)) (SETQ W (&CEQ1 U V)))
((&ANYREG V NIL)
(PROGN (&COMVAL U 1) (SETQ W (&LOCATE V))))
((&ANYREG U (LIST V))
(PROGN (&COMVAL V 1) (SETQ W (&LOCATE U))))
(T (PROGN (SETQ U (&COMLIS (CDR EXP)))
(SETQ W (&LOCATE (CADR U))))))
(&ATTACH (CONS (COND (SWITCH (QUOTE *JUMPE))
(T (QUOTE *JUMPN)))
(CONS (CAR LABL) W)))
(SETQ IREGS1 IREGS)
(SETQ REGS1 REGS)
(&ADDJMP CODELIST)))
(DE &CEQ1 (U V)
(COND ((&ANYREG U (LIST V)) (&LOCATE U))
(T (PROGN (&COMVAL U 1) (&LOCATE V)))))
(PUT (QUOTE EQ) (QUOTE COMTST) (QUOTE &CEQ))
(DE &MEMLIS (U V) (AND V (OR (&MEMB U (CAR V)) (&MEMLIS U (CDR V)))))
(DE &MEMB (U V) (COND ((ATOM V) (EQ U V)) (T (&MEMB U (CADR V)))))
(DE &RASSOC (U V)
(COND ((NULL V) NIL)
((MEMBER U (CDAR V)) (CAR V))
(T (&RASSOC U (CDR V)))))
(DE &REPASC (REG U V)
(COND ((NULL V) (LIST (LIST REG U)))
((EQUAL REG (CAAR V)) (CONS (LIST REG U) (CDR V)))
(T (CONS (CAR V) (&REPASC REG U (CDR V))))))
(DE &CLRREGS NIL
(PROG NIL
G0026(COND ((NOT IREGS) (RETURN NIL)))
(PROGN (&STORE (CADAR IREGS) (CAAR IREGS))
(SETQ IREGS (CDR IREGS)))
(GO G0026)))
(DE &GENLBL NIL
(PROG (L)
(SETQ L (GENSYM))
(SETQ LBLIST (CONS (LIST L) LBLIST))
(RETURN (LIST L))))
(DE &GETLBL (LABL)
(PROG (X)
(SETQ X (ATSOC LABL GOLIST))
(COND ((NULL X)
(LPRIE (LIST LABL (QUOTE 0 MISSING LABEL 0)))))
(RETURN (CDR X))))
(DE &FINDLBL (LBLST) (ASSOC (CAR LBLST) LBLIST))
(DE &RECHAIN (OLBL NLBL)
(PROG (X Y USES)
(SETQ X (&FINDLBL OLBL))
(SETQ Y (&FINDLBL NLBL))
(RPLACA OLBL (CAR NLBL))
(SETQ USES (CDR X))
(RPLACD X NIL)
(RPLACD Y (APPEND USES (CDR Y)))
(MAPC (FUNCTION (LAMBDA (X) (RPLACA (CDR X) (CAR NLBL)))))
USES))
(DE &MOVEUP (U)
(COND ((EQ (CAADR U) (QUOTE *JUMP))
(PROGN (SETQ JMPLIST (&DELEQ (CDR U) JMPLIST))
(RPLACW U (CDR U))
(SETQ JMPLIST (CONS U JMPLIST))))
(T (RPLACW U (CDR U)))))
(DE &ATTLBL (LBL)
(COND ((EQ (CAAR CODELIST) (QUOTE *LBL))
(&RECHAIN LBL (CDAR CODELIST)))
(T (&ATTACH (CONS (QUOTE *LBL) LBL)))))
(DE &ATTJMP (LBL)
(PROG NIL
(COND ((EQ (CAAR CODELIST) (QUOTE *LBL))
(PROGN (&RECHAIN (CDAR CODELIST) LBL)
(SETQ CODELIST (CDR CODELIST)))))
(COND ((EQ (CAAR CODELIST) (QUOTE *JUMP)) (RETURN NIL)))
(&ATTACH (CONS (QUOTE *JUMP) LBL))
(&ADDJMP CODELIST)))
(DE &ADDJMP (CLIST)
(PROG (X)
(SETQ X (&FINDLBL (CDAR CLIST)))
(RPLACD X (CONS (CAR CLIST) (CDR X)))
(SETQ JMPLIST (CONS CLIST JMPLIST))))
(DE &REMJMP (CLIST)
(PROG (X)
(SETQ X (&FINDLBL (CDAR CLIST)))
(RPLACD X (&DELEQ (CAR CLIST) (CDR X)))
(SETQ JMPLIST (&DELEQ CLIST JMPLIST))
(&MOVEUP CLIST)))
(DE &DELEQ (U V)
(COND ((NULL V) NIL)
((EQ U (CAR V)) (CDR V))
(T (CONS (CAR V) (&DELEQ U (CDR V))))))
(DE &FRAME (U)
(PROG (Z)
(SETQ STOMAP (CONS (LIST U (SETQ Z (PLUS (CADAR STOMAP) 1)))
STOMAP))
(COND ((GREATERP Z (CAR LLNGTH)) (RPLACA LLNGTH Z)))))
(DE &GETFRM (U)
((LAMBDA (X)
(COND (X (CDR X))
(T (LPRIE (LIST (QUOTE COMPILER ERROR: LOST VAR) U)))))
(ATSOC U STOMAP)))
(DE &GETFFRM (U)
(PROG (X)
(SETQ X (&GETFRM U))
(SETQ FREELST (CONS X FREELST))
(RETURN X)))
(DE &FIXUPS NIL
(PROG (FLAGG)
(MAPC (FUNCTION (LAMBDA (J)
(PROGN (SETQ STLST (&DELEQ (CADR J) STLST))
(RPLACA (CADR J) (QUOTE *NOOP)))))
SLST)
(&FIXUP1)
(COND (FLAGG
(PROGN (COND ((AND (NOT *NOLINKR)
(EQ (CAAR CODELIST) (QUOTE *LBL))
(EQ (CAADR CODELIST)
(QUOTE *LINKR)))
(RPLACA (CDR CODELIST)
(LIST (QUOTE *LINK)
(CADADR CODELIST)
(CADR (CDADR CODELIST))))))
(&ATTACH (CONS (QUOTE *DEALLOC) LLNGTH))
(&ATTACH (LIST (QUOTE *RETURN))))))
(RETURN (&FIXUP2))))
(DE &FIXUP1 NIL
(PROG (EJMPS EJMPS1 P Q)
(COND ((NOT (EQUAL (CAR CODELIST) (CONS (QUOTE *LBL) RETN)))
(&ATTLBL RETN)))
(SETQ CODELIST (CDR CODELIST))
(COND ((NOT (EQUAL (CAR CODELIST) (CONS (QUOTE *JUMP) RETN)))
(&ATTJMP RETN)))
(SETQ EJMPS (REVERSE JMPLIST))
(PROG NIL
G0027(COND ((NOT EJMPS) (RETURN NIL)))
(PROG NIL
(SETQ P (CAR EJMPS))
(SETQ EJMPS (CDR EJMPS))
(COND
((EQ (CAAR P) (QUOTE *JUMP))
(PROGN
(SETQ EJMPS1 EJMPS)
(PROG NIL
G0028(COND ((NOT EJMPS1) (RETURN NIL)))
(COND ((AND (EQUAL (CAR P) (CAAR EJMPS1))
(EQUAL (CADR P)
(CADAR EJMPS1)))
(PROGN (&REMJMP P)
(&FIXCHN P (CDAR EJMPS1))
(SETQ EJMPS1 NIL)))
(T (SETQ EJMPS1 (CDR EJMPS1))))
(GO G0028))))))
(GO G0027))
(SETQ EJMPS JMPLIST)
(COND ((NOT *NOLINKR)
(PROG NIL
G0029(COND ((NOT EJMPS) (RETURN NIL)))
(PROG NIL
(SETQ P (CAR EJMPS))
(SETQ Q (CDR P))
(SETQ EJMPS (CDR EJMPS))
(COND ((NOT (EQ (CADAR P) (CAR RETN)))
(RETURN NIL))
((OR (NOT (EQ (CAAR P)
(QUOTE *JUMP)))
(NOT (EQ (CAAR Q)
(QUOTE *LINK))))
(RETURN (SETQ FLAGG T))))
(RPLACW (CAR Q)
(CONS (QUOTE *LINKR)
(CONS (CADAR Q)
(CONS (CADDAR Q)
LLNGTH))))
(&REMJMP P))
(GO G0029)))
(T (SETQ FLAGG T)))
(&FIXFRM)
(&ATTLBL RETN)))
(DE &FINDBLK (U LBL)
(COND ((NULL (CDR U)) NIL)
((AND (EQ (CAADR U) (QUOTE *LBL))
(MEMBER (CAADDR U) (QUOTE (*LINKR *JUMP))))
U)
((AND (GET (CAADR U) (QUOTE NEGJMP)) (EQ (CADADR U) LBL)) U)
(T (&FINDBLK (CDR U) LBL))))
(PUT (QUOTE *NOOP) (QUOTE OPTFN) (QUOTE &MOVEUP))
(PUT (QUOTE *LBL) (QUOTE OPTFN) (QUOTE &LABOPT))
(DE &LABOPT (U)
(PROG (Z)
(COND ((EQ (CADAR U) (CADADR U)) (RETURN (&REMJMP (CDR U))))
((AND (EQ (CAADR U) (QUOTE *JUMP))
(SETQ Z (GET (CAADDR U) (QUOTE NEGJMP)))
(EQ (CADAR U) (CADR (CADDR U))))
(RETURN (PROGN (SETQ Z (CONS Z
(CONS (CADADR U)
(CDDR (CADDR U)))))
(&REMJMP (CDR U))
(&REMJMP (CDR U))
(RPLACD U
(CONS Z
(CONS (CADR U) (CDDR U))))
(&ADDJMP (CDR U))
T)))
(T (RETURN NIL)))))
(DE &FIXUP2 NIL
(PROG (LABS TLABS X Y Z)
(SETQ Z CODELIST)
(PROG NIL
G0030(COND ((NOT Z) (RETURN NIL)))
(COND ((OR (NOT (SETQ X (GET (CAAR Z) (QUOTE OPTFN))))
(NOT (APPLY X (LIST Z))))
(SETQ Z (CDR Z))))
(GO G0030))
(PROG NIL
G0031(COND ((NOT CODELIST) (RETURN NIL)))
(PROGN
(COND
((EQ (CAAR CODELIST) (QUOTE *LBL))
(PROGN
(&LABOPT CODELIST)
(COND
((CDR (SETQ Z (&FINDLBL (CDAR CODELIST))))
(PROGN
(SETQ Y (CONS (CAR CODELIST) Y))
(COND
((AND (NULL (CDDR Z))
(MEMBER (CAADR Z) (QUOTE (*JUMP *LINKR)))
(EQ (CAADR Y) (QUOTE *LOAD))
(&NOLOADP (CDADR Y)
(CDR (ATSOC (CADR Z) JMPLIST))))
(PROGN
(COND
((NOT (&NOLOADP (CDADR Y) (CDR CODELIST)))
(RPLACW (CDR CODELIST)
(CONS (CADR Y)
(CONS (CADR CODELIST)
(CDDR CODELIST))))))
(RPLACW (CDR Y) (CDDR Y))))
(T (PROGN (COND ((AND (NULL (CDDR Z))
(EQ (CAADR CODELIST)
(QUOTE *JUMP))
(GET (CAADR Z)
(QUOTE NEGJMP)))
(SETQ LABS (CONS (CONS (CADR Z)
Y)
LABS))))
(COND ((MEMBER (CAADR CODELIST)
(QUOTE (*JUMP *LINKR)))
(SETQ TLABS
(CONS (CONS (CADAR Y) Y)
TLABS))))))))))))
((AND (GET (CAAR CODELIST) (QUOTE NEGJMP))
(SETQ Z (ATSOC (CAR CODELIST) LABS)))
(PROGN
(SETQ X (CAR CODELIST))
(SETQ CODELIST (CDR CODELIST))
(SETQ Z (CDDR Z))
(PROG NIL
G0032(COND ((NOT (AND (EQUAL (CAR Y) (CAR Z))
(OR (EQ (CAAR Y)
(QUOTE *STORE))
(AND (EQ (CAAR Y)
(QUOTE *LOAD))
(NOT (EQ (CADAR Y)
1))))))
(RETURN NIL)))
(PROGN (SETQ CODELIST (CONS (CAR Y) CODELIST))
(RPLACW Z (CONS (CADR Z) (CDDR Z)))
(SETQ Y (CDR Y)))
(GO G0032))
(SETQ CODELIST (CONS X CODELIST))
(SETQ Y (CONS X Y))))
((AND (EQ (CAAR CODELIST) (QUOTE *JUMP))
(SETQ Z (ATSOC (CADAR CODELIST) TLABS))
(SETQ X (&FINDBLK (CDR CODELIST)
(COND ((EQ (CAAR Y)
(QUOTE *LBL))
(CADAR Y))
(T NIL)))))
(PROG (W)
(COND
((NOT (EQ (CAADR X) (QUOTE *LBL)))
(PROGN
(COND
((NOT (EQ (CAAR X) (QUOTE *LBL)))
(SETQ X
(CDR (RPLACD X
(CONS (CONS (QUOTE *LBL)
(&GENLBL))
(CDR X)))))))
(SETQ W (CONS (GET (CAADR X) (QUOTE NEGJMP))
(CONS (CADAR X) (CDDADR X))))
(&REMJMP (CDR X))
(RPLACD X (CONS W (CONS (CADR X) (CDDR X))))
(&ADDJMP (CDR X))))
(T (SETQ X (CDR X))))
(SETQ W NIL)
(PROG NIL
G0033(PROGN (SETQ W (CONS (CAR Y) W))
(SETQ Y (CDR Y)))
(COND ((NOT (EQ Y (CDR Z))) (GO G0033))))
(RPLACD X (NCONC W (CDR X)))
(&REMJMP CODELIST)
(SETQ TLABS NIL)
(SETQ CODELIST (CONS NIL
(CONS (CAR Y) CODELIST)))
(SETQ Y (CDR Y))))
(T (SETQ Y (CONS (CAR CODELIST) Y))))
(SETQ CODELIST (CDR CODELIST)))
(GO G0031))
(RETURN Y)))
(DE &NOLOADP (ARGS INSTRS)
(AND (ATOM (CADR ARGS))
(OR (AND (EQ (CAAR INSTRS) (QUOTE *LOAD))
(EQUAL (CDAR INSTRS) ARGS))
(AND (EQ (CAAR INSTRS) (QUOTE *STORE))
(OR (EQUAL (CDAR INSTRS) ARGS)
(AND (NEQ (CADDAR INSTRS) (CADR ARGS))
(&NOLOADP ARGS (CDR INSTRS))))))))
(DE &FIXCHN (U V)
(PROG (X)
(PROG NIL
G0034(COND ((NOT (EQUAL (CAR U) (CAR V))) (RETURN NIL)))
(PROGN (&MOVEUP U) (SETQ V (CDR V)))
(GO G0034))
(SETQ X (&GENLBL))
(COND ((EQ (CAAR V) (QUOTE *LBL)) (&RECHAIN X (CDAR V)))
(T (RPLACW V
(CONS (CONS (QUOTE *LBL) X)
(CONS (CAR V) (CDR V))))))
(COND ((EQ (CAAR U) (QUOTE *LBL))
(PROGN (&RECHAIN (CDAR U) X) (&MOVEUP U))))
(COND ((EQ (CAAR U) (QUOTE *JUMP)) (RETURN NIL)))
(RPLACW U
(CONS (CONS (QUOTE *JUMP) X) (CONS (CAR U) (CDR U))))
(&ADDJMP U)))
(DE &FIXFRM NIL
(PROG (HOLES LST X Y Z N)
(COND ((NULL STLST) (RETURN (RPLACA LLNGTH 0))))
(SETQ N 1)
(PROG NIL
G0035(COND ((NOT (NOT (GREATERP N (CAR LLNGTH))))
(RETURN NIL)))
(PROGN (SETQ Y NIL)
(MAPC STLST
(FUNCTION (LAMBDA (LST)
(COND ((EQUAL N (CADDR LST))
(SETQ Y (CONS (CDDR LST)
Y))))))
STLST)
(MAPC (FUNCTION (LAMBDA (LST)
(COND ((EQUAL N (CAR LST))
(SETQ Y (CONS LST Y))))))
FREELST)
(COND ((NULL Y) (SETQ HOLES (CONS N HOLES)))
(T (SETQ Z (CONS (CONS N Y) Z))))
(SETQ N (PLUS N 1)))
(GO G0035))
(SETQ Y Z)
(COND ((LESSP (CAAR Z) (CAR LLNGTH))
(RPLACA LLNGTH (CAAR Z))))
(PROG NIL
G0036(COND ((NOT HOLES) (RETURN NIL)))
(PROGN
(PROG NIL
G0037(COND ((NOT (AND HOLES
(GREATERP (CAR HOLES)
(CAR LLNGTH))))
(RETURN NIL)))
(SETQ HOLES (CDR HOLES))
(GO G0037))
(COND
(HOLES (PROGN (SETQ HOLES (REVERSIP HOLES))
(MAPC (FUNCTION (LAMBDA (X)
(RPLACA X
(CAR HOLES))))
(CDAR Z))
(RPLACA LLNGTH
(COND ((OR (NULL (CDR Z))
(GREATERP (CAR HOLES)
(CAADR Z)))
(CAR HOLES))
(T (CAADR Z))))
(SETQ HOLES (REVERSIP (CDR HOLES)))
(SETQ Z (CDR Z))))))
(GO G0036))
(COND ((OR FREELST
(NULL (®P CODELIST))
(GREATERP (CAR LLNGTH) (DIFFERENCE MAXNARGS NARG)))
(RETURN NIL)))
(SETQ N (COND ((LESSP NARG 3) 3) (T (PLUS NARG 1))))
(MAPC STLST
(FUNCTION (LAMBDA (X)
(RPLACW X
(LIST (QUOTE *LOAD)
(PLUS (CADDR X) N)
(COND ((NULL (CADR X))
(QUOTE (QUOTE NIL)))
(T (LIST (QUOTE *REG)
(CADR X))))))))
SLST)
(PROG NIL
G0038(COND ((NOT Y) (RETURN NIL)))
(PROGN (MAPC (FUNCTION (LAMBDA (X)
(AND (ATOM (CAR X))
(RPLACA X
(LIST (QUOTE *REG)
(PLUS (CAR X)
N))))))
(CDAR Y))
(SETQ Y (CDR Y)))
(GO G0038))
(RPLACA LLNGTH 0)))
(DE ®P (U)
(COND ((NULL (CDR U)) T)
((AND (FLAGP (CAADR U) (QUOTE LINK))
(NOT (OR (FLAGP** (CADADR U) (QUOTE TWOREG))
(EQUAL (CAR U) (CONS (QUOTE *JUMP) RETN)))))
NIL)
(T (®P (CDR U)))))
(DE FLAGP** (U V) (AND (ATOM U) (NOT (NUMBERP U)) (FLAGP U V)))
(FLAG (QUOTE (*LINK *LINKL *LINKR)) (QUOTE LINK))
(PUT (QUOTE *JUMPN) (QUOTE NEGJMP) (QUOTE *JUMPE))
(PUT (QUOTE *JUMPE) (QUOTE NEGJMP) (QUOTE *JUMPN))
(PUT (QUOTE *JUMPNIL) (QUOTE NEGJMP) (QUOTE *JUMPT))
(PUT (QUOTE *JUMPT) (QUOTE NEGJMP) (QUOTE *JUMPNIL))